home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Diamond Collection / The Diamond Collection (Software Vault)(Digital Impact).ISO / cdr45 / mdidmo.zip / MDIDEMO.BAS < prev    next >
BASIC Source File  |  1995-01-23  |  25KB  |  752 lines
  1. '---------------------------------------------------------------------------
  2. ' MDI Background Demo Program, Copyright (c) 1994 Karl E. Peterson
  3. ' Redistributed by permission.
  4. '
  5. ' These programs may be distributed freely on the condition that it is
  6. ' distributed in full, and unmodified, and that no fee is charged for such
  7. ' distribution with the exception of reasonable media and shipping charges.
  8. ' Any or all portions of the source code may be incorporated into your own
  9. ' programs, and those programs may be distributed without payment of
  10. ' royalties on the condition that such programs differ substantially from
  11. ' this demonstration program.
  12. '
  13. ' Two sample apps are included in this package.  The first, MDILOGO, uses
  14. ' pure VB (no third-party controls) and the Windows API.  The second,
  15. ' which is perhaps the better, and certainly the cleaner, approach uses
  16. ' a custom message interceptor.  The routines in this module are used by
  17. ' both, and as such some are not required in one or the other.
  18.  
  19. ' MDILOGO demonstrates how to create an interesting background on MDI
  20. ' parent forms in Visual Basic.  It uses several different approaches to
  21. ' achieve this goal.  These include a Windows Metafile (WMF) which resizes
  22. ' to fit the background, a bitmap (BMP) centered on the background, a bitmap
  23. ' which resizes to fit the background, and finally a tiled bitmap (similar to
  24. ' Windows wallpaper) BitBlt'ed across the background.
  25. '
  26. ' The other objective was to provide a method to "hide" MDI children, since
  27. ' this is not allowed in VB.  The ShowWindow API was used to accomplish this,
  28. ' and likewise SendMessage was used to replace VB's native Arrange method.
  29. '
  30. ' The design goal of MDILOGO was to use "Pure VB", that is, no custom controls
  31. ' to accomplish the background effect.  The THREED.VBX is used to provide a
  32. ' toolbar and a status bar, but is not integral to the method.  Other than
  33. ' THREED, all methods used in this program are entirely compatable with
  34. ' the Standard Edition of Visual Basic 3.0.
  35. '
  36. ' MDIDRAW uses the custom control MsgBlast.Vbx to intercept Windows messages
  37. ' used to control the client space of the MDIParent form.  Then, using GDI
  38. ' calls, paints the background from the new MDIForm_Paint event. It is a much
  39. ' cleaner method to accomplish the objective.
  40. '
  41. ' MsgBlast is a shareware VBX distributed on the MSDNCDs.  The author is:
  42. '   The Message Blaster Custom Control
  43. '   Copyright (c) 1992 Ed Staffin
  44. '   23831 I. Dunwoody Crossing
  45. '   Atlanta, GA 30338
  46. '   CIS: 72240,2171
  47. '
  48. ' To observe the different background effects, press the "Background" button
  49. ' on the main toolbar.  This will cycle through each effect.  You may also want
  50. ' to resize the forms to see how that is handled.
  51. '
  52. ' This program was created and distributed by:
  53. '   Karl E. Peterson
  54. '   Regional Transportation Council
  55. '   1351 Officers' Row
  56. '   Vancouver, Washington 98661
  57. '   CompuServe: 72302,3707
  58. '
  59. ' Your comments or questions are invited!  Unfortunately, due to the high 
  60. ' interest in this product, no messages from the Internet will be answered
  61. ' if posted to my CompuServe Address (it simply costs too much!).  Please
  62. ' correspond *only* via CompuServe!  Thanks.
  63. '---------------------------------------------------------------------------
  64.  
  65. ' Default behavior
  66. DefInt A-Z
  67. Option Explicit
  68.  
  69. ' Document (child) tracking arrays
  70. Global fState()  As Integer
  71. Global fDoc() As New frmChild
  72.  
  73. ' State constants
  74. Global Const frmVisible = 2
  75. Global Const frmHidden = 1
  76. Global Const frmDeleted = 0
  77. Global Const HiMenu = 1
  78.  
  79. ' API Types
  80. Type Rect
  81.   Left As Integer
  82.   Top As Integer
  83.   Right As Integer
  84.   Bottom As Integer
  85. End Type
  86. Type POINTAPI
  87.   X As Integer
  88.   Y As Integer
  89. End Type
  90. Type LOGBRUSH
  91.   lbStyle As Integer
  92.   lbColor As Long
  93.   lbHatch As Integer
  94. End Type
  95. Type LOGPEN
  96.   lopnStyle As Integer
  97.   lopnWidth As POINTAPI
  98.   lopnColor As Long
  99. End Type
  100.  
  101. ' API Calls
  102. Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
  103. Declare Function GetWindow Lib "User" (ByVal hWnd As Integer, ByVal wCmd As Integer) As Integer
  104. Declare Sub GetClientRect Lib "User" (ByVal hWnd As Integer, lpRect As Rect)
  105. Declare Sub InflateRect Lib "User" (lpRect As Rect, ByVal X As Integer, ByVal Y As Integer)
  106. Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lParam As Any) As Long
  107. Declare Function ShowWindow Lib "User" (ByVal hWnd As Integer, ByVal nCmdShow As Integer) As Integer
  108. Declare Function IsWindowVisible Lib "User" (ByVal hWnd As Integer) As Integer
  109. Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
  110. Declare Function StretchBlt% Lib "GDI" (ByVal hDC%, ByVal X%, ByVal Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal nSrcWidth%, ByVal nSrcHeight%, ByVal dwRop&)
  111. Declare Function SetParent Lib "User" (ByVal hWndChild As Integer, ByVal hWndNewParent As Integer) As Integer
  112.  
  113. Declare Function GetDC Lib "User" (ByVal hWnd As Integer) As Integer
  114. Declare Function ReleaseDC Lib "User" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
  115. Declare Function SelectObject Lib "GDI" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
  116. Declare Function DeleteObject Lib "GDI" (ByVal hObject As Integer) As Integer
  117.  
  118. Declare Function CreateSolidBrush Lib "GDI" (ByVal crColor As Long) As Integer
  119. Declare Function CreatePen Lib "GDI" (ByVal nPenStyle As Integer, ByVal nWidth As Integer, ByVal crColor As Long) As Integer
  120. Declare Function CreateEllipticRgn Lib "GDI" (ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  121.  
  122. Declare Function Rectangle Lib "GDI" (ByVal hDC As Integer, ByVal X1 As Integer, ByVal Y1 As Integer, ByVal X2 As Integer, ByVal Y2 As Integer) As Integer
  123. Declare Function FillRect Lib "User" (ByVal hDC As Integer, lpRect As Rect, ByVal hBrush As Integer) As Integer
  124. Declare Function FillRgn Lib "GDI" (ByVal hDC As Integer, ByVal hRgn As Integer, ByVal hBrush As Integer) As Integer
  125. Declare Function TextOut Lib "GDI" (ByVal hDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal lpString As String, ByVal nCount As Integer) As Integer
  126.  
  127. Declare Function SetBkColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  128. Declare Function GetBkColor Lib "GDI" (ByVal hDC As Integer) As Long
  129. Declare Function SetBkMode Lib "GDI" (ByVal hDC As Integer, ByVal nBkMode As Integer) As Integer
  130. Declare Function GetBkMode Lib "GDI" (ByVal hDC As Integer) As Integer
  131. Declare Function SetTextColor Lib "GDI" (ByVal hDC As Integer, ByVal crColor As Long) As Long
  132. Declare Function GetTextColor Lib "GDI" (ByVal hDC As Integer) As Long
  133.  
  134. ' Some Windows messages watchable by MsgBlast
  135. Global Const WM_CHILDACTIVATE = &H22
  136. Global Const WM_ERASEBKGND = &H14
  137. Global Const WM_HSCROLL = &H114
  138. Global Const WM_MDIACTIVATE = &H222
  139. Global Const WM_MDICASCADE = &H227
  140. Global Const WM_MDICREATE = &H220
  141. Global Const WM_MDIDESTROY = &H221
  142. Global Const WM_MDIGETACTIVE = &H229
  143. Global Const WM_MDIICONARRANGE = &H228
  144. Global Const WM_MDIMAXIMIZE = &H225
  145. Global Const WM_MDINEXT = &H224
  146. Global Const WM_MDIRESTORE = &H223
  147. Global Const WM_MDISETMENU = &H230
  148. Global Const WM_MDITILE = &H226
  149. Global Const WM_PAINT = &HF
  150. Global Const WM_SETREDRAW = &HB
  151. Global Const WM_VSCROLL = &H115
  152.  
  153. ' MsgBlast processing options
  154. Global Const MB_PREPROCESS = -1
  155. Global Const MB_EATMESSAGE = 0
  156. Global Const MB_POSTPROCESS = 1
  157.  
  158. ' ShowWindow() Commands
  159. Global Const WM_SHOWWINDOW = &H18
  160. Global Const SW_HIDE = 0
  161. Global Const SW_SHOWNORMAL = 1
  162. Global Const SW_NORMAL = 1
  163. Global Const SW_SHOWMINIMIZED = 2
  164. Global Const SW_SHOWMAXIMIZED = 3
  165. Global Const SW_MAXIMIZE = 3
  166. Global Const SW_SHOWNOACTIVATE = 4
  167. Global Const SW_SHOW = 5
  168. Global Const SW_MINIMIZE = 6
  169. Global Const SW_SHOWMINNOACTIVE = 7
  170. Global Const SW_SHOWNA = 8
  171. Global Const SW_RESTORE = 9
  172.  
  173. ' MDI messages (previously defined)
  174. 'Global Const WM_MDITILE = &H226
  175. 'Global Const WM_MDICASCADE = &H227
  176. 'Global Const WM_MDIICONARRANGE = &H228
  177.  
  178. ' wParam values for WM_MDITILE and WM_MDICASCADE messages.
  179. Global Const MDITILE_VERTICAL = &H0
  180. Global Const MDITILE_HORIZONTAL = &H1
  181. Global Const MDITILE_SKIPDISABLED = &H2 'Requires Win 3.1
  182.  
  183. ' GetWindow() Constants
  184. Global Const GW_HWNDFIRST = 0
  185. Global Const GW_HWNDLAST = 1
  186. Global Const GW_HWNDNEXT = 2
  187. Global Const GW_HWNDPREV = 3
  188. Global Const GW_OWNER = 4
  189. Global Const GW_CHILD = 5
  190.  
  191. ' WindowState
  192. Global Const NORMAL = 0    ' 0 - Normal
  193. Global Const MINIMIZED = 1 ' 1 - Minimized
  194. Global Const MAXIMIZED = 2 ' 2 - Maximized
  195.  
  196. ' System Color(s)
  197. Global Const APPLICATION_WORKSPACE = &H8000000C ' Background color of multiple document interface (MDI) applications.
  198.  
  199. ' Raster-ops (Ternary)
  200. Global Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
  201. Global Const SRCPAINT = &HEE0086  ' (DWORD) dest = source OR dest
  202. Global Const SRCAND = &H8800C6  ' (DWORD) dest = source AND dest
  203. Global Const SRCINVERT = &H660046 ' (DWORD) dest = source XOR dest
  204. Global Const SRCERASE = &H440328  ' (DWORD) dest = source AND (NOT dest )
  205. Global Const NOTSRCCOPY = &H330008  ' (DWORD) dest = (NOT source)
  206. Global Const NOTSRCERASE = &H1100A6 ' (DWORD) dest = (NOT src) AND (NOT dest)
  207. Global Const MERGECOPY = &HC000CA ' (DWORD) dest = (source AND pattern)
  208. Global Const MERGEPAINT = &HBB0226  ' (DWORD) dest = (NOT source) OR dest
  209. Global Const PATCOPY = &HF00021 ' (DWORD) dest = pattern
  210. Global Const PATPAINT = &HFB0A09  ' (DWORD) dest = DPSnoo
  211. Global Const PATINVERT = &H5A0049 ' (DWORD) dest = pattern XOR dest
  212. Global Const DSTINVERT = &H550009 ' (DWORD) dest = (NOT dest)
  213. Global Const BLACKNESS = &H42&  ' (DWORD) dest = BLACK
  214. Global Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE
  215.  
  216. ' StretchBlt() Modes
  217. Global Const BLACKONWHITE = 1
  218. Global Const WHITEONBLACK = 2
  219. Global Const COLORONCOLOR = 3
  220.  
  221. ' Pen Styles
  222. Global Const PS_SOLID = 0
  223. Global Const PS_DASH = 1        '  -------
  224. Global Const PS_DOT = 2 '  .......
  225. Global Const PS_DASHDOT = 3     '  _._._._
  226. Global Const PS_DASHDOTDOT = 4  '  _.._.._
  227. Global Const PS_NULL = 5
  228. Global Const PS_INSIDEFRAME = 6
  229.  
  230. ' ScaleMode
  231. Global Const USER = 0        ' 0 - User
  232. Global Const TWIPS = 1       ' 1 - Twip
  233. Global Const POINTS = 2      ' 2 - Point
  234. Global Const PIXELS = 3      ' 3 - Pixel
  235. Global Const CHARACTERS = 4  ' 4 - Character
  236. Global Const INCHES = 5      ' 5 - Inch
  237. Global Const MILLIMETERS = 6 ' 6 - Millimeter
  238. Global Const CENTIMETERS = 7 ' 7 - Centimeter
  239.  
  240. ' GetSystemMetrics() codes
  241. Global Const SM_CXSCREEN = 0
  242. Global Const SM_CYSCREEN = 1
  243. Global Const SM_CXVSCROLL = 2
  244. Global Const SM_CYHSCROLL = 3
  245. Global Const SM_CYCAPTION = 4
  246. Global Const SM_CXBORDER = 5
  247. Global Const SM_CYBORDER = 6
  248. Global Const SM_CXDLGFRAME = 7
  249. Global Const SM_CYDLGFRAME = 8
  250. Global Const SM_CYVTHUMB = 9
  251. Global Const SM_CXHTHUMB = 10
  252. Global Const SM_CXICON = 11
  253. Global Const SM_CYICON = 12
  254. Global Const SM_CXCURSOR = 13
  255. Global Const SM_CYCURSOR = 14
  256. Global Const SM_CYMENU = 15
  257. Global Const SM_CXFULLSCREEN = 16
  258. Global Const SM_CYFULLSCREEN = 17
  259. Global Const SM_CYKANJIWINDOW = 18
  260. Global Const SM_MOUSEPRESENT = 19
  261. Global Const SM_CYVSCROLL = 20
  262. Global Const SM_CXHSCROLL = 21
  263. Global Const SM_DEBUG = 22
  264. Global Const SM_SWAPBUTTON = 23
  265. Global Const SM_RESERVED1 = 24
  266. Global Const SM_RESERVED2 = 25
  267. Global Const SM_RESERVED3 = 26
  268. Global Const SM_RESERVED4 = 27
  269. Global Const SM_CXMIN = 28
  270. Global Const SM_CYMIN = 29
  271. Global Const SM_CXSIZE = 30
  272. Global Const SM_CYSIZE = 31
  273. Global Const SM_CXFRAME = 32
  274. Global Const SM_CYFRAME = 33
  275. Global Const SM_CXMINTRACK = 34
  276. Global Const SM_CYMINTRACK = 35
  277. Global Const SM_CMETRICS = 36
  278.  
  279. Sub DisplayStatus (StatTxt$)
  280.  
  281.   'Update status bar on main form
  282.     If frmMain!pStatus <> StatTxt$ Then
  283.       frmMain!pStatus = StatTxt$
  284.     End If
  285.  
  286. End Sub
  287.  
  288. Sub mdiArrange (method%)
  289.   
  290.   'Use the MDI Arrange methods rather than VB's because it can
  291.   'ignore disabled (hidden) children.
  292.     Dim Ret%
  293.     Select Case method
  294.       Case WM_MDICASCADE
  295.     Ret = SendMessage(GetWindow(frmMain.hWnd, GW_CHILD), WM_MDICASCADE, MDITILE_SKIPDISABLED, 0&)
  296.       Case MDITILE_HORIZONTAL
  297.     Ret = SendMessage(GetWindow(frmMain.hWnd, GW_CHILD), WM_MDITILE, MDITILE_HORIZONTAL Or MDITILE_SKIPDISABLED, 0&)
  298.       Case MDITILE_VERTICAL
  299.     Ret = SendMessage(GetWindow(frmMain.hWnd, GW_CHILD), WM_MDITILE, MDITILE_VERTICAL Or MDITILE_SKIPDISABLED, 0&)
  300.       Case WM_MDIICONARRANGE
  301.     Ret = SendMessage(GetWindow(frmMain.hWnd, GW_CHILD), WM_MDIICONARRANGE, MDITILE_SKIPDISABLED, 0&)
  302.     End Select
  303.  
  304. End Sub
  305.  
  306. Sub mdiBitBltCentered (sWnd%, sDC%, dWnd%)
  307.   
  308.   'Initialize some variables
  309.     Dim nRet%, cDC%, cWnd%, dX%, dY%
  310.     Dim sR As Rect, dR As Rect
  311.  
  312.   'get DC to client space (assumes we're Blt'ing onto an MDI client space)
  313.     cWnd = GetWindow(dWnd, GW_CHILD)
  314.     cDC = GetDC(cWnd)
  315.   
  316.   'Get source and destination rectangles
  317.     Call GetClientRect(sWnd, sR)
  318.     Call GetClientRect(cWnd, dR)
  319.  
  320.   'Calc parameters
  321.     dX = (dR.Right - sR.Right) \ 2
  322.     dY = (dR.Bottom - sR.Bottom) \ 2
  323.  
  324.   'Do it
  325.     nRet = BitBlt(cDC, dX, dY, sR.Right, sR.Bottom, sDC, 0, 0, SRCCOPY)
  326.  
  327.   'and clean up
  328.     nRet = ReleaseDC(cWnd, cDC)
  329.  
  330. End Sub
  331.  
  332. Sub mdiBitBltTiled (sWnd%, sDC%, dWnd%)
  333.   
  334.   'Initialize some variables
  335.     Dim nRet%, cDC%, cWnd%, dX%, dY%
  336.     Dim Rows%, Cols%, I%, j%
  337.     Dim sR As Rect, dR As Rect
  338.  
  339.   'get DC to client space (assumes we're Blt'ing onto an MDI client space)
  340.     cWnd = GetWindow(dWnd, GW_CHILD)
  341.     cDC = GetDC(cWnd)
  342.   
  343.   'Get source and destination rectangles
  344.     Call GetClientRect(sWnd, sR)
  345.     Call GetClientRect(cWnd, dR)
  346.  
  347.   'Calc parameters
  348.     Rows = dR.Right \ sR.Right
  349.     Cols = dR.Bottom \ sR.Bottom
  350.  
  351.   'Spray out across destination
  352.     For I = 0 To Rows
  353.       dX = I * sR.Right
  354.       For j = 0 To Cols
  355.     dY = j * sR.Bottom
  356.     nRet = BitBlt(cDC, dX, dY, sR.Right, sR.Bottom, sDC, 0, 0, SRCCOPY)
  357.       Next j
  358.     Next I
  359.  
  360.   'and clean up
  361.     nRet = ReleaseDC(cWnd, cDC)
  362.  
  363. End Sub
  364.  
  365. Sub mdiEnforceHidden ()
  366.   
  367.   'Required because when one child is maximized, then restored,
  368.   'the "hidden" children are again visible (sometimes).
  369.   Dim I%, Ret%
  370.   For I = 1 To UBound(fState)
  371.     If Not fDoc(I)!mMain(0).Visible Then
  372.       'Child menu not visible, so child shouldn't be either!
  373.     Ret% = ShowWindow(fDoc(I).hWnd, SW_HIDE)
  374.     End If
  375.   Next I
  376.  
  377. End Sub
  378.  
  379. Function mdiFreeIndex () As Integer
  380.     
  381.   Dim I%, ArrayCount%
  382.   ArrayCount = UBound(fDoc)
  383.  
  384.   ' Cycle throught the document array. If one of the
  385.   ' documents has been deleted, then return that index
  386.   For I = 1 To ArrayCount
  387.     If fState(I) = frmDeleted Then
  388.       mdiFreeIndex = I
  389.       Exit Function
  390.     End If
  391.   Next
  392.  
  393.   ' If none of the elements in the document array have
  394.   ' been deleted, then increment the document and the
  395.   ' state arrays by one and return the index to the
  396.   ' new element.
  397.   ReDim Preserve fDoc(ArrayCount + 1)
  398.   ReDim Preserve fState(ArrayCount + 1)
  399.   mdiFreeIndex = UBound(fDoc)
  400.  
  401. End Function
  402.  
  403. Sub mdiHide (Frm As Form)
  404.   
  405.     Dim I%, Ret%
  406.   'Hidden maximized is *asking* for trouble!
  407.     If Frm.WindowState = MAXIMIZED Then
  408.       Frm.WindowState = NORMAL
  409.     End If
  410.  
  411.   'Hide menu so it won't show up on parent if it's
  412.   'the last hidden form, then disable & hide form.
  413.     Frm.Enabled = False
  414.     Ret% = ShowWindow(Frm.hWnd, SW_HIDE)
  415.     For I = 0 To HiMenu
  416.       Frm!mMain(I).Visible = False
  417.     Next I
  418.   
  419.   'Set focus to next child
  420.     Ret = SendMessage(GetWindow(frmMain.hWnd, GW_CHILD), WM_MDINEXT, 0, 0&)
  421.  
  422. End Sub
  423.  
  424. Sub mdiNew ()
  425.  
  426.   'Get first available index into forms arrays
  427.     Dim fIndex%
  428.     fIndex = mdiFreeIndex()
  429.   
  430.   'Set new child's state
  431.     fState(fIndex) = frmVisible
  432.  
  433.   'Implicitly load and set properties
  434.     fDoc(fIndex).Caption = "Child:" & Format(fIndex)
  435.     fDoc(fIndex).Tag = fIndex
  436.     fDoc(fIndex).Refresh
  437.     fDoc(fIndex)!mMain(0).Caption = "&" & fDoc(fIndex).Caption
  438.     fDoc(fIndex)!mForm(0).Caption = fDoc(fIndex)!mForm(0).Caption & fDoc(fIndex).Caption
  439.     fDoc(fIndex)!mForm(1).Caption = fDoc(fIndex)!mForm(1).Caption & fDoc(fIndex).Caption
  440.  
  441. End Sub
  442.  
  443. Sub mdiPaintGradiant (hWndParent%)
  444.  
  445.   'initialize some vars
  446.     Const Shades% = 64
  447.     Dim cWnd%, cDC%, nRet%, I%
  448.     Dim FillBoxHeight%
  449.     Dim cRect As Rect
  450.     Dim NewBrush%
  451.     Static fRect(1 To Shades) As Rect
  452.  
  453.   'get DC to client space
  454.     cWnd = GetWindow(hWndParent, GW_CHILD)
  455.     cDC = GetDC(cWnd)
  456.   
  457.   'set up a structure of rectangles for fills
  458.     Call GetClientRect(cWnd, cRect)
  459.     FillBoxHeight = cRect.Bottom \ Shades
  460.     For I = 1 To Shades
  461.       fRect(I).Left = cRect.Left
  462.       fRect(I).Right = cRect.Right
  463.       fRect(I).Top = (I - 1) * FillBoxHeight
  464.       fRect(I).Bottom = fRect(I).Top + FillBoxHeight
  465.     Next I
  466.  
  467.   'make up for slop on last one
  468.     fRect(Shades).Bottom = cRect.Bottom
  469.  
  470.   'fill-er-up!
  471.     For I = Shades - 1 To 0 Step -1
  472.       NewBrush = CreateSolidBrush(RGB(0, 0, (I + 1) * 4 - 1))
  473.       nRet = FillRect(cDC, fRect(Shades - I), NewBrush)
  474.       nRet = DeleteObject(NewBrush)
  475.     Next I
  476.   
  477.   'and clean up
  478.     nRet = ReleaseDC(cWnd, cDC)
  479.  
  480. End Sub
  481.  
  482. Sub mdiPaintSolid (hWndParent%, FillColor&)
  483.  
  484.   Dim cWnd%, cDC%, nRet%
  485.   Dim cRect As Rect
  486.   Dim NewBrush%, OldBrush%
  487.   Dim NewPen%, OldPen%
  488.  
  489.   cWnd = GetWindow(hWndParent, GW_CHILD)
  490.   cDC = GetDC(cWnd)
  491.   
  492.   NewBrush = CreateSolidBrush(FillColor)
  493.   OldBrush = SelectObject(cDC, NewBrush)
  494.   NewPen = CreatePen(PS_SOLID, 1, FillColor)
  495.   OldPen = SelectObject(cDC, NewPen)
  496.  
  497.   Call GetClientRect(cWnd, cRect)
  498.   nRet = Rectangle(cDC, cRect.Left, cRect.Top, cRect.Right, cRect.Bottom)
  499.   
  500.   nRet = SelectObject(cDC, OldBrush)
  501.   nRet = DeleteObject(NewBrush)
  502.   nRet = SelectObject(cDC, OldPen)
  503.   nRet = DeleteObject(NewPen)
  504.   nRet = ReleaseDC(cWnd, cDC)
  505.  
  506. End Sub
  507.  
  508. Sub mdiPaintTunnel1 (hWndParent%)
  509.  
  510.   'initialize some vars
  511.     Const Shades% = 64
  512.     Dim cWnd%, cDC%, nRet%, I%
  513.     Dim dX%, dY%
  514.     Dim cRect As Rect
  515.     Dim NewBrush%
  516.  
  517.   'get DC and rectangle of client space
  518.     cWnd = GetWindow(hWndParent, GW_CHILD)
  519.     cDC = GetDC(cWnd)
  520.     Call GetClientRect(cWnd, cRect)
  521.     dX% = cRect.Right / Shades \ 2
  522.     dY% = cRect.Bottom / Shades \ 2
  523.  
  524.   'fill-er-up!
  525.     For I = Shades - 1 To 0 Step -1
  526.       NewBrush = CreateSolidBrush(RGB((I + 1) * 4 - 1, 0, 0))
  527.       nRet = FillRect(cDC, cRect, NewBrush)
  528.       nRet = DeleteObject(NewBrush)
  529.       InflateRect cRect, -dX, -dY
  530.     Next I
  531.   
  532.   'and clean up
  533.     nRet = ReleaseDC(cWnd, cDC)
  534.  
  535. End Sub
  536.  
  537. Sub mdiPaintTunnel2 (hWndParent%)
  538.  
  539.   'initialize some vars
  540.     Const Shades% = 32
  541.     Dim cWnd%, cDC%, nRet%, I%
  542.     Dim dX%, dY%
  543.     Dim cRect As Rect
  544.     Dim NewBrush%, eRgn%
  545.  
  546.   'get DC and rectangle of client space
  547.     cWnd = GetWindow(hWndParent, GW_CHILD)
  548.     cDC = GetDC(cWnd)
  549.     Call GetClientRect(cWnd, cRect)
  550.     dX% = cRect.Right / Shades / 2
  551.     dY% = cRect.Bottom / Shades / 2
  552.  
  553.   'fill background
  554.     NewBrush = CreateSolidBrush(RGB(0, 255, 0))
  555.     nRet = FillRect(cDC, cRect, NewBrush)
  556.     nRet = DeleteObject(NewBrush)
  557.  
  558.   'fill-er-up!
  559.     For I = Shades - 1 To 0 Step -1
  560.       NewBrush = CreateSolidBrush(RGB(0, (I + 1) * 8 - 8, 0))
  561.       eRgn = CreateEllipticRgn(cRect.Left, cRect.Top, cRect.Right, cRect.Bottom)
  562.       nRet = FillRgn(cDC, eRgn, NewBrush)
  563.       nRet = DeleteObject(NewBrush)
  564.       nRet = DeleteObject(eRgn)
  565.       Call InflateRect(cRect, -dX, -dY)
  566.     Next I
  567.   
  568.   'and clean up
  569.     nRet = ReleaseDC(cWnd, cDC)
  570.  
  571. End Sub
  572.  
  573. Sub mdiSetBkColor (hWndParent%, NewBkColor&)
  574.  
  575.   Dim cWnd%, cDC%, lRet&, nRet%
  576.   cWnd = GetWindow(hWndParent, GW_CHILD)
  577.   cDC = GetDC(cWnd)
  578.   lRet = SetBkColor(cDC, NewBkColor&)
  579.   Debug.Print Hex$(lRet)
  580.   nRet = ReleaseDC(cWnd, cDC)
  581.  
  582. End Sub
  583.  
  584. Sub mdiShowAll ()
  585.   
  586.   'Use ShowWindow API to make all "hidden" children visible again
  587.     Dim I%, j%, Ret%
  588.     For I = 1 To UBound(fState)
  589.       If fState(I) <> frmDeleted Then
  590.     If IsWindowVisible(fDoc(I).hWnd) = False Then
  591.       'Set menus visible again
  592.         For j = 0 To HiMenu
  593.           fDoc(I)!mMain(j).Visible = True
  594.         Next j
  595.       'Unhide child
  596.         Ret% = ShowWindow(fDoc(I).hWnd, SW_SHOWNA)
  597.       'Reenable child and set focus to it
  598.         fDoc(I).Enabled = True
  599.         fDoc(I).SetFocus
  600.     End If
  601.       End If
  602.     Next I
  603.  
  604. End Sub
  605.  
  606. Sub mdiStretchBlt (sWnd%, sDC%, dWnd%, Proportional%)
  607.  
  608.   'Initialize some variables
  609.     Dim nRet%, cDC%, cWnd%
  610.     Dim sR As Rect, dR As Rect
  611.     Dim fac!, dX%, dY%
  612.  
  613.   'get DC to client space (assumes we're Blt'ing onto an MDI client space)
  614.     cWnd = GetWindow(dWnd, GW_CHILD)
  615.     cDC = GetDC(cWnd)
  616.   
  617.   'Get source and destination rectangles
  618.     Call GetClientRect(sWnd, sR)
  619.     Call GetClientRect(cWnd, dR)
  620.  
  621.   'Alter destination if proportional
  622.     If Proportional Then
  623.       If dR.Bottom / sR.Bottom < dR.Right / sR.Right Then
  624.     'Height is constraining dimension
  625.     fac! = dR.Bottom / sR.Bottom
  626.     dX = (dR.Right - (fac! * sR.Right)) \ -2
  627.       Else
  628.     'Width is constraining dimension
  629.     fac! = dR.Right / sR.Right
  630.     dY = (dR.Bottom - (fac! * sR.Bottom)) \ -2
  631.       End If
  632.       InflateRect dR, dX, dY
  633.     End If
  634.   
  635.   'Stretch out across destination
  636.     nRet = StretchBlt(cDC, dR.Left, dR.Top, dR.Right - dR.Left, dR.Bottom - dR.Top, sDC, 0, 0, sR.Right, sR.Bottom, SRCCOPY)
  637.  
  638.   'and clean up
  639.     nRet = ReleaseDC(cWnd, cDC)
  640.  
  641. End Sub
  642.  
  643. Sub mdiTextOut (dWnd%, Text$, dX%, dY%)
  644.  
  645.   'Initialize some vars
  646.     Dim nRet%, cWnd%, cDC%
  647.  
  648.   'Get DC to client space (assumes we're Blt'ing onto an MDI client space)
  649.     cWnd = GetWindow(dWnd, GW_CHILD)
  650.     cDC = GetDC(cWnd)
  651.  
  652.   'Do it!
  653.     nRet = TextOut(cDC, dX, dY, Text$, Len(Text$))
  654.   
  655.   'and clean up
  656.     nRet = ReleaseDC(cWnd, cDC)
  657.  
  658. End Sub
  659.  
  660. Sub StretchBltPictToForm (Source As PictureBox, Destination As Form)
  661.  
  662.   'Initialize some variables
  663.     Dim Ret%, sDC%, dDC%, sSM%, dSM%
  664.     Dim sW%, sH%, dW%, dH%
  665.   
  666.   'Store scalemodes, set to PIXELS
  667.     sSM = Source.ScaleMode
  668.     dSM = Destination.ScaleMode
  669.     Source.ScaleMode = PIXELS
  670.     Destination.ScaleMode = PIXELS
  671.  
  672.   'Calc parameters
  673.     dDC = Destination.hDC
  674.     dH = Destination.ScaleHeight
  675.     dW = Destination.ScaleWidth
  676.     sDC = Source.hDC
  677.     sH = Source.ScaleHeight
  678.     sW = Source.ScaleWidth
  679.  
  680.   'Stretch out across destination
  681.     Ret = StretchBlt(dDC, 0, 0, dW, dH, sDC, 0, 0, sW, sH, SRCCOPY)
  682.  
  683.   'Restore original scalemodes
  684.     Source.ScaleMode = sSM
  685.     Destination.ScaleMode = dSM
  686.  
  687. End Sub
  688.  
  689. Sub StretchImageToForm (Source As Image, Target As Form)
  690.  
  691.   'Initialize some vars
  692.     Dim h1%, h2%, w1%, w2%
  693.     Dim newLeft%, newTop%, newWidth%, newHeight%
  694.  
  695.   'Use variables rather than properties for speed
  696.     h1 = Target.ScaleHeight
  697.     h2 = Source.Height
  698.     w1 = Target.ScaleWidth
  699.     w2 = Source.Width
  700.  
  701.   'Set new size so as not to warp proportions
  702.     If h1 / h2 < w1 / w2 Then 'Height is constraining dimension
  703.       newWidth = ((h1 / h2) * w2)
  704.       newLeft = (w1 - newWidth) \ 2
  705.       Source.Move newLeft, 0, newWidth, h1
  706.     Else 'Width is constraining dimension
  707.       newHeight = ((w1 / w2) * h2)
  708.       newTop = (h1 - newHeight) \ 2
  709.       Source.Move 0, newTop, w1, newHeight
  710.     End If
  711.  
  712. End Sub
  713.  
  714. Sub TiledBitBltPictToForm (Source As PictureBox, Destination As Form)
  715.  
  716.   'Assumes Source is not visible
  717.  
  718.   'Initialize some variables
  719.     Dim Ret%, sDC%, dDC%, sSM%, dSM%
  720.     Dim sX%, sY%, sW%, sH%, dX%, dY%
  721.     Dim Rows%, Cols%, I%, j%
  722.   
  723.   'Store scalemodes, set to PIXELS
  724.     sSM = Source.ScaleMode
  725.     dSM = Destination.ScaleMode
  726.     Source.ScaleMode = PIXELS
  727.     Destination.ScaleMode = PIXELS
  728.  
  729.   'Calc parameters
  730.     sDC = Source.hDC
  731.     dDC = Destination.hDC
  732.     sH = Source.ScaleHeight
  733.     sW = Source.ScaleWidth
  734.     Rows = Destination.ScaleWidth \ sW
  735.     Cols = Destination.ScaleHeight \ sH
  736.  
  737.   'Spray out across destination
  738.     For I = 0 To Rows
  739.       dX = I * sW
  740.       For j = 0 To Cols
  741.     dY = j * sH
  742.     Ret = BitBlt(dDC, dX, dY, sW, sH, sDC, sX, sY, SRCCOPY)
  743.       Next j
  744.     Next I
  745.  
  746.   'Restore original scalemodes
  747.     Source.ScaleMode = sSM
  748.     Destination.ScaleMode = dSM
  749.  
  750. End Sub
  751.  
  752.